perm filename JUST.F4[NEW,LCS]2 blob
sn#155906 filedate 1975-04-18 generic text, type T, neo UTF8
00100 C TO JUSTIFY SEVERAL MSS FILES AT ONCE. (UP TO 15.)(8*15=120)
00110 C TO CONVERT(ONE FILE AT A TIME)TO NEW FORMAT, USE 'CONVT' AS 'LAST NAME'.
00200 COMMON/XRN/ RN(20000)/PTR/PWDS(2500) ,RSTFAC(120),STFF(120),
00400 1 V(200),JR(120)/RR4/R4,R5,P1,P2,I,M
00450 C M=NUM OF STAVES. (BY 8S)
00500 COMMON JY,L,R8,R9,RDIS /RS/JW(120)
00550
00700 TYPE 1
00800 1 FORMAT(' FILE NAME 1? '$)
00900 ACCEPT 200,N1
01000 200 FORMAT(A5)
01100 TYPE 300
01200 300 FORMAT(' LAST NAME? '$)
01300 ACCEPT 200,N2
01310 TYPE 3011
01320 3011 FORMAT(' TYPE OUTPUT NAME 1 -- '$)
01330 ACCEPT 200,NMX
01340 IF(N2.EQ.'CONVT')GO TO 111
01400 TYPE 100
01500 100 FORMAT(' POS.1, POS.2 - '$)
01600 ACCEPT 111,P1,P2
01650 IF(P2.EQ.0)P2=200
01700 111 FORMAT(2F)
01800 IF(NMX.EQ.' ')NMX='AAAAA'
01900
01910 JW(1)=1
01920 JR(1)=1
02000 M=1
02100 L=0
02200 JX=1
02300 IX=1
02400 NX=1
02500 NM=N1
02600 40 CALL IFILE(1,NM)
02700 READ (1)J,I,
02800 1 (PWDS(K),K=JX,JX+J),(RN(K),K=IX,I+IX-2),ISCR,(V(K),K=1,ISCR),
02900 1 ISCR,(V(K),K=1,ISCR),(RSTFAC(K),K=NX,NX+7),(STFF(K),K=
03000 1 NX,NX+7),K
03100
03200 IF(N2.EQ.'CONVT')GO TO 2
03210 C ********* TYPE 999 AS POS1. FOR 'CONVERT', NAME2 WILL BE OUTPUT NM.
03300 RX=NX-1
03500
03560 IF(RX.EQ.0)GO TO 410
03600 DO 41 K=JX,JX+J
03700 PWDS(K)=PWDS(K)+L
03800 KX=PWDS(K)+2
03820 C +2 IS FOR STAFF #
03840 41 RN(KX)=RN(KX)+RX
03900 410 IX=I+IX-1
03910 L=IX-1
04000 JX=J+JX
04010 JW(M+1)=JX
04020 C POINTER TO START OF PWDS FOR EACH FILE
04030 JR(M+1)=IX
04100 NX=NX+8
04200 IF(IX.LT.19500)GO TO 400
04300 RRT=IX
04400 TYPE 111,RRT
04500 400 IF(NM.EQ.N2)GO TO 5
04600 NM=NM+2
04700 M=M+1
04800 GO TO 40
04900
05700 2 JJ=1
05800 3001 L=PWDS(JJ)
05900 K=L+1
06000 A=RN(K)
06010 Z=RN(L)
06100 IF(A.LT.5)GO TO 3002
06200 IF(A.LE.10)GO TO 1177
06250 IF(A.NE.20)GO TO 3002
06300 1177 IF(A.NE.6)GO TO 3003
06400 RN(K)=9
06500 GO TO 3002
06600 3003 IF(A.NE.5)GO TO 3004
06700 RN(K)=10
06800 IF(Z.LT.4)GO TO 3010
07000 CALL EXCH(RN(L+5),RN(L+6))
07200 GO TO 3002
07300 3004 IF(A.NE.7)GO TO 3005
07400 RN(K)=17
07500 GO TO 3010
07600 3005 IF(A.EQ.8)RN(K)=5
07700 IF(A.EQ.9)RN(K)=6
07800 IF(A.NE.10)GO TO 3006
07900 RN(K)=8
07910 IF(Z.LT.4)GO TO 3010
07920 CALL EXCH(RN(L+4),RN(L+5))
07930 CALL EXCH(RN(L+6),RN(L+5))
08000 GO TO 3002
08100 3006 IF(A.EQ.20)RN(K)=7
08200 IF(A.NE.18)GO TO 3002
08300 3010 FORMAT(' ITEM ',I3,', CODE ',F3.0)
08400 TYPE 3010,JJ,A
08410 3002 A=RN(L+2)
08420 RN(L+2)=RN(L+3)
08430 RN(L+3)=A
08500 A=L+Z+3
08600 JJ=JJ+1
08700 IF(A.EQ.PWDS(JJ))GO TO 3001
10000 MX=1
10100 CC IF(N2.NE.' ')NM=N2
10200 GO TO 6
10300
10400 5 I=JX-1
10500 C TOTAL IN RN ('I' IN MXX.F4)
10600 CALL JJUST
10700
10800 C START OF WRITER
10810 6 NM=NMX
10900 JX=1
11000 IX=1
11100 NX=1
11300 L=0
11400
11600 MX=M
11700 M=1
11800 7 CALL OFILE(21,NM)
11900 IF(N2.EQ.'CONVT')GO TO 3
12000 J=JW(M+1)-JW(M)
12100 I=JR(M+1)-JR(M)+1
12200 P1=PWDS(JX+J)
12300 RX=NX-1
12350 IF(RX.EQ.0)GO TO 3
12400 DO 61 K=JX,JX+J-1
12500 KX=PWDS(K)
12600 PWDS(K)=KX-L
12700 KX=KX+2
12800 61 RN(KX)=RN(KX)-RX
12850 PWDS(JX+J)=PWDS(JX+J)-L
12900 3 L=I+IX-2
13000 WRITE(21)J,I,
13100 1 (PWDS(K),K=JX,JX+J),(RN(K),K=IX,L),ISCR,(V(K),K=1,ISCR),
13200 1 ISCR,(V(K),K=1,ISCR),(RSTFAC(K),K=NX,NX+7),(STFF(K),K=
13300 1 NX,NX+7),JR
13400 PWDS(JX+J)=P1
13500 TYPE 60,NM
13600
13700 IF(M.EQ.MX)CALL EXIT
13800 M=M+1
13900 JX=JW(M)
14000 IX=JR(M)
14100
14200 NX=NX+8
14300 END FILE 21
14400 NM=NM+2
14500 GO TO 7
14600 60 FORMAT(1XA5)
14700 END
14800
14900 SUBROUTINE JJUST
15000 DATA RSP/.5/,RI/4.5/,RPX/.2/
15100 COMMON JY,L,R8,R9,RDIS /NNP/NP(2000)
15125 1 /MMV/MV(3000) /KJY/KY,LY
15150 C INCREASE NP AND MV IF NEEDED
15200 COMMON/XRN/ RN(20000)/PTR/PWDS(2500)
15300 1,RSTFAC(120),STFF(120),R(2,100),JR(120)/RR4/R4,R5,P1,P2,I,M
15400
15500 DIMENSION IR(2,100)
15600 EQUIVALENCE (R,IR)
15800 IX=PWDS(I+1)-1
15900 PRCNT=1.
16100 RRT=P2
16150 R5=P2
16200 RZRO=P1
16300 R4=P1
16400 IF(RRT.EQ.0)RRT=200
16500 IF(RZRO.EQ.0)RZRO=.001
16600 JCNT=0
16700 RJSZ=RI
16800 CALL BIGGET
16850 C BIG GETPTS FAIL ROUTINE
16900 ML=1
17000 ROV=RRT
17100 19 IF(JCNT.GT.9)GO TO 101
17110 RP=PRCNT
17200 RJSZ=RJSZ-RPX
17300 JCNT=JCNT+1
17400 C TEMPORARY COUNTER
17500 TYPE 111,JCNT
17600 111 FORMAT(I4)
17700
17800 DO 11 KN=-3,M*8-4
17900 RSPC=0
18400 R8=KN
18500 N=0
18600
18700 DO 2 K=1,KY
18800 L=NP(K)
18900 RA=RN(L+1)
19000 RB=RN(L+3)
19210 IF(RN(L+2).EQ.R8)GO TO 77
19220 IF(RA.NE.4)GO TO 2
19230 C SKIPS HOMED NOTES (IN CHORDS)
19240 77 IF(RA.EQ.1)GO TO 10
19250 27 IF(RA.LE.4)GO TO 177
19260 IF(RA.LT.17)GO TO 2
19270 C LOOKS AT NOTES,RESTS,CLEFS,BAR LINES,KSIGS,METERS.
19280 177 IF(RA.NE.4)GO TO 10
19290 IF(RN(L).GT.2)GO TO 2
19600 C SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
19700 10 N=N+1
19800 R(1,N)=RB
19900 IR(2,N)=L
20000 IF(N.EQ.100)GO TO 28
20100 C ONLY TREATS 100 ITEMS AT A TIME.
20200
20300
20400 2 CONTINUE
20500
20600 IF(N.EQ.0)GO TO 11
20700 CC28 KM=JFAC(L)
20800 C SEE FUNCTION JFAC. RSTFAC PNTR.
20900 28 DO 23 K=1,N
21000 23 IF(RN(IR(2,K)+1).NE.4)GO TO 24
21100 C SKIPS IF ONLY BAR LINES ON THIS STAFF
21200 GO TO 11
21300 24 RSTJC=RSTFAC(KN+4)*PRCNT
21400 CALL SORT2(R,N)
21500
21600 C JUMP IF LAST IS A BAR LINE.
21700 K=0
21800 JLDGR=0
21900 JX=0
22000 22 K=K+1
22100 122 L=IR(2,K)
22200 RA=RN(L+1)
22300 RB=0
22400 RX=RN(L+5)
22410 C RX=PARAM 5
22455 RX6=RN(L+6)
22500 RY=1
22600 RW=AMOD(RN(L+4),100.)
22700 IF(RA.GT.1)GO TO 4
22800 RZ=RN(L+7)
22900 IF(LDGR.NE.JLDGR)JLDGR=0
23000 LDGR=0
23100 JY=K
23200 DO 32 JJ=JY+1,N+1
23300 K=JJ
23400 32 IF(R(1,JJ)-R(1,JJ-1).GT.RSP)GO TO 35
23500 C FOUND HOW MANY MEMBERS TO CHORD.
23600 35 RB=0
23700 K=K-1
23800 RQ=0
23900 RD=0
24000 125 IF(AMOD(RN(L+4),200.).GT.60.)RY=.6
24100 DO 37 JJ=JY,K-1
24200 IF(RD.NE.0)GO TO 38
24300 C FINDS ONLY HIGH OR! LOW LED. LINE.
24400 JIR=IR(2,JJ)
24500 RW=AMOD(RN(JIR+4),100.)
24600 IF(RW.GT.12)GO TO 277
24610 IF(RW.GE.2)GO TO 38
24620 277 LDGR=-1
24800 IF(RW.GT.12)LDGR=1
24900 IF(JLDGR.EQ.LDGR)GO TO 36
25000 JLDGR=LDGR
25100 C LDGR IS FOR LEDGER LINES.
25200 GO TO 38
25300 36 RD=1.5
25400 RQ=RD
25500 38 IF(RB.GT.2)GO TO 222
25600 C JUMP IF LARGE SPACE AFTER NOTE IS ALREADY SET UP.
25700 RZZ=RN(JIR+7)
25800 RE=RN(JIR+5)
26210 IF(RB.GE.2)GO TO 477
26220 IF(RZZ.GE.10)GO TO 377
26230 IF(RE.GE.20)GO TO 477
26240 IF(AMOD(RZZ,10.).EQ.0)GO TO 477
26250 377 RB=1.5+EXTEN(RZZ)
26260 C SPACE FOR DOT OR TAIL(IF STEM UP)
26270 477 IF(ABS(RN(JIR+6)).EQ.10)RB=RB+2
26300 C FOR CHORD TONES ON RIGHT OF STEM UP.
26400 C LOOKS THROUGH ALL NOTES OF A CHORD.
26500 222 IF(AMOD(RE,10.).EQ.0)GO TO 37
26600 C JUMP IF NO ACCIS.
26700 425 RD=2*RY+EXTEN(RE)
26800 IF(RQ.GT.RD)RD=RQ
26900 RQ=RD
27000 C FUNCT. EXTEN=AMOD(X,1.)*10.
27100 37 CONTINUE
27200 IF(RY.NE.1)RB=RB-.5*RJSZ
27300 C MINI NOTES NEED LESS SPACE
27400 25 IF(JX.GT.0)R(2,JX)=R(2,JX)+RD*RSTJC
27500 GO TO 17
27600 4 IF(RA.NE.3)GO TO 29
27700 RB=3
27800 IF(RX.GT.100)RB=1.5
27900 C CHECK ON SIZE NEEDED FOR CLEFS
28000 29 IF(RA.NE.4)GO TO 26
28100 RB=-RJSZ/2
28200 RD=.9
28300 GO TO 25
28400 26 IF(RA.NE.18)GO TO 30
28500 IF(RX6.GT.9)GO TO 31
28510 IF(RX.GT.9)GO TO 31
28600 C CHECKS FOR 2-DIGIT METERS
28700 RB=-1
28800 RD=1
28900 GO TO 25
29000 31 RB=2
29100 RD=3
29200 GO TO 25
29300 30 IF(RA.NE.17)GO TO 17
29500 RB=2*(ABS(RX)-1)-2
29600 RD=2
29700 GO TO 25
29800 C SPACES FOR CORRECT NUM OF ACCIS.
29900 17 RC=(RB+RJSZ)*RSTJC
30000 C RJSZ=DEFAULT SIZE
30100 JX=JX+1
30200 R(2,JX)=RC
30300 R(1,JX)=R(1,K)
30400 3 IF(K.LT.N)GO TO 22
30500 RA=R(1,1)
30600 RB=R(2,1)
30700
30800 DO 13 KX=2,JX
30900 RE=R(1,KX)
31000 C POS. BEFORE SHIFTING
31100 IF(ABS(RE-RA).GT..5)GO TO 14
31200 IF(R(2,KX).GT.RB)GO TO 16
31300 C SKIPS DOUBLE STOPS AND VERY CLOSE ITEMS
31400 GO TO 13
31500 CC IF(RZZ.LE.RB)GO TO 13
31600 C JUMP WHEN SPACE TO ADD IS SMALLER THAN WHAT'S ALREADY THERE
31700 CC RB=RZZ-RB
31800 14 RD=RA+RB-RE
31900 IF(RD.LE.0)GO TO 16
32000 C THERE'S ENOUGH ROOM
32100 CC RD=RA+RB-RE+RD
32150 ROV=ROV+RD
32175
32200 140 R4=RE+RSPC-.001
32300 R5=1000
32400 C MAYBE MORE? ↑↑↑↑↑
32500 R8=RD
32600 R9=0
32900 C GO EXPAND IT
33000 IF(R(2,KX).EQ.0)GO TO 15
33010 CALL MOVIT
33020 R5=R4
33030 R4=RA+.001+RSPC
33040 R8=R4
33050 R9=R5+RD-.001
33060 C FOR ITEMS ON OTHER LINES.
33070 CALL MOVIT
33080 15 RSPC=RSPC+RD
33090 C RSPC SAVES TOTAL SPACE ADDED
33100 16 RB=R(2,KX)
33200 13 RA=RE
33300 11 CONTINUE
33400 110 IF(ROV.LE.RRT+.01)RETURN
33500 IF(RJSZ.GT.4)RJSZ=4
33600 PRCNT=(ROV-RZRO)/(RRT-RZRO)
34000 IF(PRCNT.NE.RP)GO TO 19
34100 101 R4=RZRO
34200 R5=ROV
34300 R8=RZRO
34400 R9=RRT-.001
34500 C JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
34600 CALL MOVIT
34610 END
41900
42000 C THESE MOVE ENDS OF PARTIAL INNER BEAMS.
42100 SUBROUTINE MVBEAM(I)
42200 C L AND JY ARE FOR MOVES TO DIFF. STAFF.
42310 COMMON JY,L,R8,R9,RDIS /XRN/RN(20000)
42400 Y=RN(JY+I)
42500 Z=ABS(Y)
42600 IF(Z.LT.100.)GO TO 1
42700 C NEXT FOR MINIS, DIAMONDS, 'X' NOTES. (LIMIT OF +-99 ON ALTITUDE.)
42800 Y=AMOD(Y,100.)
42900 X=Y+R8
43000 Z=Z-ABS(Y)+ABS(X)
43100 C PUTS ALL INTO POSITIVE
43200 IF(X)Z=-Z
43300 GO TO 2
43400 1 Z=Y+R8
43500 2 RN(L+I)=Z
43600 END